home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / feel0_89.lha / Feel / Modules / complex.em < prev    next >
Text File  |  1993-07-12  |  7KB  |  255 lines
  1. ;; Eulisp Module
  2. ;; Author: pab
  3. ;; File: complex.em
  4. ;; Date: Fri Dec  4 12:22:01 1992
  5. ;;
  6. ;; Project:
  7. ;; Description: 
  8. ;;
  9.  
  10. (defmodule complex
  11.   (standard0
  12.    list-fns
  13.    numbers
  14.    )
  15.   ()
  16.   
  17.  
  18.   (defclass <complex> (<number>)
  19.     ((real initarg real reader real-part)
  20.      (imag initarg imag reader imag-part))
  21.     )
  22.  
  23.   (defclass <gaussian> (<complex>)
  24.     ()
  25.     constructor (make-gaussian real imag))
  26.   
  27.   (defclass <real-complex> (<complex>)
  28.     ()
  29.     constructor (make-real-complex real imag))
  30.   
  31.   (defgeneric make-complex (x y)
  32.     methods ((((x <float>) (y <float>))
  33.           (make-real-complex x y))
  34.          (((x <integer>) (y <integer>))
  35.           (make-gaussian x y))
  36.          (((x <number>) (y <number>))
  37.           (lift make-complex x y))))
  38.   
  39.   (defmethod generic-prin ((z <complex>) stream)
  40.     (format stream "#C(~a+~ai)" (real-part z) (imag-part z)))
  41.  
  42.   (defmethod generic-write ((z <complex>) stream)
  43.     (format stream "#C(~a+~ai)" (real-part z) (imag-part z)))
  44.   
  45.  
  46.   (defmethod binary+ ((z1 <complex>) (z2 <complex>))
  47.     (make-complex (binary+ (real-part z1) (real-part z2))
  48.           (binary+ (imag-part z1) (imag-part z2))))
  49.  
  50.   (defmethod binary- ((z1 <complex>) (z2 <complex>))
  51.     (make-complex (binary- (real-part z1) (real-part z2))
  52.           (binary- (imag-part z1) (imag-part z2))))
  53.  
  54.   (defmethod negate ((z1 <complex>))
  55.     (make-complex (negate (real-part z1))
  56.           (negate (imag-part z1))))
  57.  
  58.   (defmethod binary* ((z1 <complex>) (z2 <complex>))
  59.     (make-complex (binary- (binary* (real-part z1) (real-part z2))
  60.                (binary* (imag-part z1) (imag-part z2)))
  61.           (binary+ (binary* (real-part z1) (imag-part z2))
  62.                (binary* (imag-part z1) (real-part z2)))))
  63.  
  64.   (defmethod binary/ ((z1 <complex>) (z2 <complex>))
  65.     (let ((mod2 (binary+ (binary* (real-part z2) (real-part z2))
  66.              (binary* (imag-part z2) (imag-part z2)))))
  67.       (make-complex (binary/ (binary+ (binary* (real-part z1) (real-part z2))
  68.                       (binary* (imag-part z1) (imag-part z2)))
  69.                  mod2)
  70.             (binary/ (binary- (binary* (imag-part z1) (real-part z2))
  71.                       (binary* (real-part z1) (imag-part z2)))
  72.                  mod2))))
  73.   
  74.   (defmethod = ((z1 <complex>) (z2 <complex>))
  75.     (and (= (real-part z1) (real-part z2))
  76.      (= (imag-part z1) (imag-part z2))))
  77.  
  78.  
  79.   (defmethod quotient ((x <gaussian>) (y <gaussian>))
  80.     (binary/ x y))
  81.   
  82.   (defmethod remainder ((x <gaussian>) (y <gaussian>))
  83.     (binary- x (binary* (quotient x y) y)))
  84.  
  85.   ;; I'll leave this to someone who knows the answer....
  86.   '(defmethod binary-gcd ((x <gaussian>) (y <gaussian>))
  87.      (labels ((g-aux (a b)
  88.              (print (list a b))
  89.              (let ((r (remainder a b)))
  90.                (if (= r 0) b
  91.              (g-aux b r)))))
  92.          (g-aux x y)))
  93.            
  94.  
  95.   (defmethod lift-numbers ((x <complex>) (y <float>))
  96.     <complex>)
  97.  
  98.   (defmethod lift-numbers ((x <complex>) (y <integer>))
  99.     <complex>)
  100.  
  101.   (defmethod (converter <complex>) ((x <integer>))
  102.     (make-complex x 0))
  103.  
  104.   (defmethod (converter <complex>) ((x <float>))
  105.     (make-complex x 0))
  106.   
  107.   (defmethod (converter <real-complex>) ((x <gaussian>))
  108.     (+ (convert 0.0 <complex>) x))
  109.  
  110.   (defconstant i (make-complex 0 1.0))
  111.  
  112.   (defconstant I (make-complex 0 1))
  113.  
  114.  
  115.   ;; Polar representation for complex numbers
  116.   (defclass <angle> (<number>) 
  117.     ((v initarg v accessor angle-value))
  118.     constructor (make-angle v))
  119.   
  120.   (defmethod initialize-instance ((x <angle>) lst)
  121.     (let ((x (call-next-method)))
  122.       ((setter angle-value) x
  123.        (- (angle-value x) (* (floor (/ (angle-value x) (* 2 pi)))
  124.                  (* 2 pi))))
  125.       x))
  126.  
  127.   (defmethod binary+ ((x <angle>) (y <angle>))
  128.     (make-angle (+ (angle-value x) (angle-value y))))
  129.  
  130.   (defmethod binary- ((x <angle>) (y <angle>))
  131.     (make-angle (- (angle-value x) (angle-value y))))
  132.   
  133.   (defmethod binary* ((x <angle>) (y <float>))
  134.     (make-angle (* (angle-value x) y)))
  135.  
  136.   (defmethod binary/ ((x <angle>) (y <float>))
  137.     (make-angle (/ (angle-value x) y)))
  138.  
  139.   (defmethod binary* ((y <float>) (x <angle>))
  140.     (make-angle (* (angle-value x) y)))
  141.  
  142.   (defmethod binary/ ((y <float>) (x <angle>))
  143.     (make-angle (/ (angle-value x) y)))
  144.  
  145.   (defmethod = ((x <angle>) (y <angle>))
  146.     (= (angle-value x) (angle-value y)))
  147.   
  148.   (defmethod negate ((x <angle>))
  149.     (make-angle (- (angle-value x))))
  150.  
  151.   (defmethod sin ((x <angle>))
  152.     (sin (angle-value x)))
  153.   (defmethod cos ((x <angle>))
  154.     (cos (angle-value x)))
  155.   (defmethod tan ((x <angle>))
  156.     (tan (angle-value x)))
  157.  
  158.   (defmethod generic-prin ((x <angle>) s)
  159.     (format s "#<~a rads>" (angle-value x)))
  160.   (defmethod generic-write ((x <angle>) s)
  161.     (format s "#<~a rads>" (angle-value x)))
  162.  
  163.   (defclass <polar> (<number>)
  164.     ((r initarg r accessor polar-r)
  165.      (theta initarg theta accessor polar-theta))
  166.     constructor (make-polar r theta)
  167.     )
  168.  
  169.   (defmethod (converter <complex>) ((x <polar>))
  170.     (make-complex (* (cos (polar-theta x))
  171.              (polar-r x))
  172.           (* (sin (polar-theta x))
  173.              (polar-r x))))
  174.   
  175.   (defmethod (converter <polar>) ((x <complex>))
  176.     (let ((x (convert x <real-complex>)))
  177.       (let ((real (real-part x))
  178.         (imag (imag-part x)))
  179.     (make-polar (sqrt (+ (* real real) (* imag imag)))
  180.             (cond ((positivep real) 
  181.                (make-angle (atan (/ imag real))))
  182.               ((negativep real)
  183.                (make-angle (+ (atan (/ imag real)) pi)))
  184.               ((positivep imag) 
  185.                (make-angle (/ pi 2)))
  186.               (t (make-angle (/ pi -2))))))))
  187.  
  188.   (defmethod binary+ ((x <polar>) (y <polar>))
  189.     (convert (binary+ (convert x complex) (convert y complex))
  190.          polar))
  191.  
  192.   (defmethod binary- ((x <polar>) (y <polar>))
  193.     (convert (binary- (convert x complex) (convert y complex))
  194.          polar))
  195.  
  196.   (defmethod binary* ((x <polar>) (y <polar>))
  197.     (make-polar (binary* (polar-r x) (polar-r y))
  198.         (binary+ (polar-theta x) (polar-theta y))))
  199.  
  200.   (defmethod binary/ ((x <polar>) (y <polar>))
  201.     (make-polar (binary/ (polar-r x) (polar-r y))
  202.         (binary- (polar-theta x) (polar-theta y))))
  203.   
  204.   (defmethod = ((x <polar>) (y <polar>))
  205.     (and (= (polar-r x) (polar-r y))
  206.      (= (polar-theta x) (polar-theta y))))
  207.   
  208.   (defmethod lift-numbers ((y <polar>) (x <complex>))
  209.     polar)
  210.  
  211.   (defmethod lift-numbers ((y <polar>) (x <float>))
  212.     polar)
  213.  
  214.   (defmethod lift-numbers ((y <polar>) (x <integer>))
  215.     polar)
  216.  
  217.   (defmethod (converter <polar>) ((x <integer>))
  218.     (make-polar (convert x <double-float>) (make-angle 0)))
  219.  
  220.   (defmethod (converter <polar>) ((x <float>))
  221.     (make-polar x (make-angle 0)))
  222.  
  223.   (defmethod generic-prin ((x <polar>) y)
  224.     (format y "#<polar: ~a (~a)>" (polar-r x) (polar-theta x)))
  225.   (defmethod generic-write ((x <polar>) y)
  226.     (format y "#<polar: ~a (~a)>" (polar-r x) (polar-theta x)))
  227.  
  228.   (defmethod exp ((x <complex>))
  229.     (convert (make-polar (exp (real-part x))
  230.              (make-angle (imag-part x)))
  231.          <complex>))
  232.   
  233.   (defmethod exp ((x <polar>))
  234.     (exp (convert x <complex>)))
  235.  
  236.   (defmethod log ((x <polar>))
  237.     (convert (make-complex (log (polar-r x))
  238.                (angle-value (polar-theta x)))
  239.          polar))
  240.  
  241.   (defmethod log ((x <complex>))
  242.     (convert (log (convert x polar))
  243.          <complex>))
  244.  
  245.   (defmethod sin ((x <complex>))
  246.     (/ (- (exp (* i x))
  247.       (exp (* (- i) x)))
  248.        2))
  249.  
  250.   (export make-complex i I <complex> <gaussian>)
  251.  
  252.   ;; end module
  253.   )
  254.  
  255.